home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
boi120p.zip
/
UNITS.ZIP
/
SUPPORT.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1990-12-12
|
15KB
|
451 lines
{$D-} { Disable Debug Information }
{$S-} { Disable Stack Checking }
{$V-} { Disable String Checking }
Unit Support;
{ Part of BBS Onliner Interface }
{ Copyright (C) 1990 Andrew J. Mead
All Rights Reserved. }
{ original version 9/5/90
history found in IOLIB.PAS }
INTERFACE
Var
playerpoints : longint; { player score variable }
Procedure ABORTGAME( { notify player that his screen is not big enough }
limit : byte); { minimum screen lines needed }
Procedure LINEWRITE( { write a menu option }
lstr : string; { menu selection to write }
lcheck : boolean); { highlight option indicator }
Procedure QUERYUSER; { prompt player for color choice }
Function WRITECOPY( { display copyright screen }
gamename, { name of current game }
version, { version of current game }
regnum, { regisration number of current game }
regstr, { name of BBS }
homestr : string; { name of at home version of game }
isreg, { registered game indicator }
ishome, { at home version of game exists indicator }
askq : boolean) { check for Instructions request indicator }
: boolean; { returns true if Instructions are requested }
Procedure ENDGAME( { Do Hall of Fame Housekeeping }
gamename, { name of current program }
playstr, { classification string (Player,Trader,etc...) }
regstr, { name of BBS }
hoffile : string; { name of Text Hall of Fame }
isreg, { registered game indicator }
isvalid, { game results are valid for HOF listing indicator }
iscash, { cash/points value indicator }
gethigh : boolean); { higher/lower scores are better }
IMPLEMENTATION
Uses
boidecl,
getcmbbs,
iolib,
dos;
Var
inchar : char; { standard input character }
etemp : boolean;
Procedure ABORTGAME;
begin {* AbortGame *}
ClrPortScr;
PortBackground(black);
TextPortColor(white);
TextPortColor(lightgray);
SendString('Your setup shows that your screen only displays ',false);
TextPortColor(white);
SendString(IntStr(pagelength,0),false);
TextPortColor(lightgray);
SendString(' lines.',true);
SendString('This game requires a minimum of ',false);
TextPortColor(white);
SendString(IntStr(limit,0),false);
TextPortColor(lightgray);
SendString(' lines.',true);
SendString('Check your BBS settings and make the needed changes before trying again.',true);
SendString('Thank you. Please press almost any key to return to your BBS. ',false);
ClearBuffers;
inchar := ReadPortKey;
SendString('',true);
SendString('',true);
SendString('Please wait... returning to the BBS.',true);
EndPort;
Halt
end; {* AbortGame *}
Procedure LINEWRITE(lstr : string; lcheck : boolean);
begin {* LineWrite *}
SendString(lstr[1],false);
if lcheck then TextPortColor(white);
SendString(lstr[2],false);
TextPortColor(lightgray);
SendString(copy(lstr,3,length(lstr)),false)
end; {* LineWrite *}
Procedure QUERYUSER;
begin {* QueryUser *}
ClrPortScr;
TextPortColor(white);
SendString('Before we get started, please answer the following question.',true);
SendString('',true);
TextPortColor(lightgray);
SendString('Do you want color? [Y/N] ',false);
repeat inchar := upcase(ReadPortKey) until inchar in ['Y','N'];
if inchar = 'Y' then
begin
DoColor := true;
PortColor(lightblue,white);
SendString('Yes',true)
end
else
begin
DoColor := false;
TextPortColor(white);
SendString('No',true)
end;
SendString('',true);
TextPortColor(white);
SendString('Thank you. Please enjoy the game.',true)
end; {* QueryUser *}
Function WRITECOPY;
begin {* WriteCopy *}
etemp := doecho;
if not dolocal then doecho := true;
ClrPortScr;
PortBackground(black);
PortColor(yellow,white);
SendString(gamename,false);
PortColor(cyan,lightgray);
SendString(' version ' + version + '.',true);
SendString('Program Copyright (C) 1990 Andrew J. Mead',true);
SendString('All Rights Reserved.',true);
SendString('',true);
TextPortColor(white);
SendString('BBS Onliner Interface',false);
PortColor(cyan,lightgray);
SendString(' version ' + interfaceversion + '.',true);
SendString('Copyright(C) 1990 Andrew J. Mead',true);
SendString('All Rights Reserved.',true);
SendString('Contact: POB 1155 Chapel Hill, NC 27514-1155',true);
SendString('',true);
if isreg then
begin
SendString('Your SysOp has registered this game. SN: '+regnum,true);
PortColor(random(7) + 1,white);
SendString(regstr,true);
PortColor(cyan,lightgray);
SendString('Support your local BBSs that support ShareWare.',true)
end
else SendString('This is a Test Copy of '+gamename+'. If you like it, please register.',true);
SendString('',true);
if ishome then
SendString('Ask your SysOp for '+homestr+', the home version of this popular game.',true);
GotoPorTXY(1,pagelength);
PortColor(lightmagenta,lightgray);
if askq then SendString('Press ''I'' for instructions, or any other key to begin. ',false)
else SendString('Press almost any key to begin. ',false);
ClearBuffers;
inchar := upcase(ReadPortKey);
doecho := etemp;
WriteCopy := inchar = 'I'
end; {* WriteCopy *}
Procedure ENDGAME;
type
str40 = string [40];
hofrec = record
hname : str40;
amount : longint;
month : word;
date : word;
year : word
end;
hofarr = array [1..24] of hofrec;
var
e : file of hofarr;
et : text;
hof : hofarr;
eloop : byte;
etemp : byte;
dohof : boolean;
dummy : word;
tempname : str40;
hofdex : byte;
alltimehigh : boolean;
updatetext : boolean;
nextmonth : boolean;
usetemp : boolean;
topten : boolean;
noalt : boolean;
eyear : word;
emonth : word;
edate : word;
edow : word;
workline : string;
firstmatch : byte;
totalmatch : byte;
Function HOFCHECK : boolean;
var
hloop : byte;
begin {* HofCheck *}
if usename then
begin
for hloop := 1 to 20 do if username = hof[hloop].hname then
begin
Inc(totalmatch);
if totalmatch = hoflim then firstmatch := hloop
end;
HofCheck := playerpoints > hof[firstmatch].amount
end
else HofCheck := true
end; {* HofCheck *}
Function GOODSCORE : boolean;
begin {* EndGame,fGoodScore *}
if gethigh then GoodScore := (playerpoints > hof[20].amount)
else GoodScore := (playerpoints < hof[20].amount) or (hof[20].amount = 0)
end; {* EndGame,fGoodScore *}
Function BETTERSCORE : boolean;
begin {* EndGame,fBetterScore *}
if gethigh then BetterScore := (playerpoints > hof[hofdex - 1].amount)
else BetterScore := (playerpoints < hof[hofdex - 1].amount) or (hof[20].amount = 0)
end; {* EndGame,fBetterScore *}
begin {* EndGame *}
updatetext := false;
nextmonth := false;
firstmatch := 20;
totalmatch := 0;
usetemp := usename;
GetDate(eyear,emonth,edate,edow);
assign(e,gamepath + hoffile);
if Exist(gamepath + hoffile) then
begin
reset(e);
read(e,hof);
close(e);
if (hof[1].amount > 0) and (emonth <> hof[1].month) then
begin
nextmonth := true;
updatetext := true;
move(hof[1],hof[21],3*sizeof(hof[21]));
for eloop := 1 to 20 do with hof[eloop] do
begin
hname := '';
amount := 0;
month := emonth;
date := edate;
year := eyear
end;
rewrite(e);
write(e,hof);
close(e)
end
end
else
begin
fillchar(hof,sizeof(hof),0);
for eloop := 1 to 24 do with hof[eloop] do
begin
hname := '';
amount := 0;
month := emonth;
date := edate;
year := eyear
end
end;
if iscash then
begin
SendString('Your game has ended. Your final holdings are worth ',false);
TextPortColor(white);
SendString('$' + IntStr(playerpoints,0),false);
TextPortColor(lightgray);
SendString('.',true)
end
else
begin
SendString('Your game has ended. Your final score is ',false);
TextPortColor(white);
SendString(IntStr(playerpoints,0),false);
TextPortColor(lightgray);
SendString(' points.',true)
end;
dohof := false;
if GoodScore and isvalid and HofCheck then
begin
dohof := true;
SendString('You have qualified for the Hall of Fame',false);
if usename then
begin
tempname := username;
SendString('.',true)
end
else
begin
SendString(', please enter your name:',true);
tempname[0] := chr(0);
TextPortColor(white);
GetString(tempname)
end;
TextPortColor(lightgray);
hofdex := 21;
while BetterScore and (hofdex > 1) do Dec(hofdex);
move(hof[hofdex],hof[hofdex + 1],(firstmatch - hofdex) * sizeof(hofrec));
hof[hofdex].hname := tempname;
hof[hofdex].amount := playerpoints;
GetDate(hof[hofdex].year,hof[hofdex].month,hof[hofdex].date,dummy)
end;
SendString('',true);
SendString('',true);
PortWindow(1,1,80,pagelength);
GotoPortXY(1,Min(24,pagelength));
SendString('Press almost any key to see the Hall of Fame. ',false);
ClearBuffers;
inchar := ReadPortKey;
usename := false;
ClrPortScr;
TextPortColor(white);
etemp := length(gamename);
while length(gamename) < 50 do gamename := ' ' + gamename;
SendString(gamename + ' Hall Of Fame',true);
Delete(gamename,1,length(gamename) - etemp);
TextPortColor(lightgray);
SendString(' Player Rank Amount Date',true);
for eloop := 1 to 20 do with hof[eloop] do if amount > 0 then
begin
if dohof and (eloop = hofdex) then PortColor(lightblue,white)
else if eloop = 1 then TextPortColor(white) else TextPortColor(lightgray);
SendString(PadStr(hname,40) + IntStr(eloop,5) + IntStr(amount,14) +
IntStr(month,5) + '/' + IntStr(date,0) +'/' + IntStr(year,0),false);
if dohof and (eloop = hofdex) then SendString(' <--',true)
else SendString('',true)
end;
SendString('',true);
alltimehigh := false;
if dohof then
begin
if (hofdex = 1) and (playerpoints > hof[24].amount) then
begin
alltimehigh := true;
move(hof[hofdex],hof[24],sizeof(hof[24]));
updatetext := true;
end
else if hofdex <= 10 then
begin
topten := true;
updatetext := true
end;
rewrite(e);
write(e,hof);
close(e)
end;
if updatetext then
begin
assign(et,texthof);
rewrite(et);
workline := regstr + ' - ' + gamename + ' - Hall Of Fame';
{ 1} writeln(et,workline:length(workline) div 2 + 40);
{ 2} writeln(et);
if hof[24].amount > 0 then
begin
workline := '- All Time High Score -';
{ 3} writeln(et,workline:length(workline)div 2 + 45);
{ 4} writeln(et,hof[24].hname:40,' ',hof[24].amount:10,' ',
hof[24].month:0,'/',hof[24].date:0,'/',hof[24].year:0)
end;
{ 5} writeln(et);
if hof[21].amount > 0 then
begin
workline := '- Last Month''s Top Three -';
{ 6} writeln(et,workline:length(workline) div 2 + 45);
for eloop := 21 to 23 do if hof[eloop].amount > 0 then
{ 7- 9} writeln(et,hof[eloop].hname:40,' ',hof[eloop].amount:10,' ',
hof[eloop].month:0,'/',hof[eloop].date:0,'/',hof[eloop].year:0);
{10} writeln(et)
end;
workline := '- This Month''s Top ' + playstr + ' -';
{11} writeln(et,workline:length(workline) div 2 + 45);
for eloop := 1 to 10 do if hof[eloop].amount > 0 then
{12-21} writeln(et,hof[eloop].hname:40,' ',hof[eloop].amount:10,' ',
hof[eloop].month:0,'/',hof[eloop].date:0,'/',hof[eloop].year:0);
close(et)
end;
SendString('',true);
TextPortColor(lightgray);
if alltimehigh then SendString('Your final amount was the ALL-TIME HIGH!!',true)
else
begin
SendString('Your final amount was ',false);
TextPortColor(white);
if iscash then
begin
SendString('$' + IntStr(playerpoints,0),false);
TextPortColor(lightgray);
SendString('.',true)
end
else
begin
SendString(IntStr(playerpoints,0),false);
TextPortColor(lightgray);
SendString(' points.',true)
end
end;
if doagain and ((not usetime) or ((not timexp) and (againtime < LeftTime))) then
begin
TextPortColor(lightgray);
if usetime then SendString('You have less than '+IntStr(LeftTime,0)+' minutes remaining.',true);
SendString('Would you like to play again? [Y/N] ',false);
ClearBuffers;
TextPortColor(white);
repeat inchar := ReadPortKey until upcase(inchar) in ['Y','N'];
SendString(inchar,true);
if upcase(inchar) = 'N' then doagain := false else usename := usetemp
end
else doagain := false;
if not doagain then
begin
TextPortColor(lightgray);
if isreg then
begin
SendString('Press almost any key to return to ',false);
PortColor(random(7) + 1,white);
SendString(regstr,false);
TextPortColor(lightgray);
SendString('.',false)
end
else SendString('Press almost any key to return to your BBS.',false);
ClearBuffers;
inchar := ReadPortKey;
SendString('',true);
SendString('',true);
TextPortColor(lightgray);
if isreg then
begin
SendString('Please wait. Returning to ',false);
PortColor(random(7) + 1,white);
SendString(regstr,false);
TextPortColor(lightgray);
SendString('.',true)
end
else SendString('Please wait. Returning to the BBS.',true)
end
end; {* EndGame *}
end. Unit